(define $compilation-output-port (make-fluid (current-output-port)))
(define (compilation-output)
  (fluid $compilation-output-port))

(define $indentation (make-fluid 0))
(define (indentation)
  (fluid $indentation))

(define $newline? (make-fluid #f))

(define (with-compilation-output port thunk)
  (let-fluids $compilation-output-port port
	      $indentation 0
	      $newline? #f
	      thunk))

(define (emit-attribute string)
  (emit-text-line string))

(define (emit-type type)
  (emit-text (native-name type)))

(define (emit-name atom)
  (maybe-indent)
  (display atom (compilation-output)))

(define (emit-token atom)
  (let ((out (compilation-output)))
    (maybe-indent)
    (cond ((char? atom)
	   (display "'" out)
	   (case atom
	     ((#\newline)
	      (display "\\n" out))
	     ((#\\)
	      (display "\\\\" out))
	     ((#\')
	      (display "\\'" out))
	     (else
	      (display atom out)))
	   (display "'" out))
	  ((and (number? atom)
		(inexact? atom))
	   (display atom out)
	   (display "0" out))
	  (else
	   (write (cond ((eq? atom #f)
			 'false)
			((eq? atom #t)
			 'true)
			((eq? atom '())
			 'null)
			(else
			 atom))
		  out)))))

(define (emit-text string)
  (maybe-indent)
  (display string (compilation-output)))

(define (emit-text-line string)
  (maybe-indent)
  (display string (compilation-output))
  (emit-newline))

(define (emit-formatted-text format-string . args)
  (maybe-indent)
  (apply format (compilation-output)
	 format-string args))

(define (emit-formatted-text-line format-string . args)
  (maybe-indent)
  (apply format (compilation-output)
	 format-string args)
  (emit-newline))

(define (emit-newline)
  (newline (compilation-output))
  (set-fluid! $newline? #t))

(define (maybe-indent)
  (define port (compilation-output))
  (when (fluid $newline?)
    (let loop ((n (indentation)))
      (cond ((zero? n))
	    (else
	     (display #\space port)
	   (loop (- n 1)))))
    (set-fluid! $newline? #f)))

(define (with-indent indent thunk)
  (let-fluid $indentation (+ (indentation) indent)
	     thunk))

;;;;
;;;; UTILS
;;;;

(define (cs-style id type?)
  (define l (string->list (if (symbol? id)
			      (symbol->string id)
			      id)))
  (list->string
   (let loop ((chars l)
	      (capitalize? type?))
     (if (null? chars)
	 '()
	 (let ((first (car chars))
	       (rest (cdr chars)))
	   (cond ((char=? first #\-)
		  (if (and (pair? rest)
			   (eq? (car rest)
				#\>))
		      (cons #\2
			    (loop (cdr rest) #f))
		      (loop rest #t)))
		 ((char=? first #\+)
		  (cons* #\P
			 #\L
			 (loop rest #f)))
		 ((char=? first #\>)
		  (cons* #\G
			 #\T
			 (loop rest #f)))
		 ((char=? first #\<)
		  (cons* #\L
			 #\T
			 (loop rest #f)))
		 ((char=? first #\=)
		  (cons* #\E
			 #\Q
			 (loop rest #f)))
		 ((char=? first #\?)
		  (cons #\P
			(loop rest #f)))
		 ((char=? first #\!)
		  (cons #\B
			(loop rest #f)))
		 ((char=? first #\/)
		  (cons* #\S
			 #\L
			 (loop rest #f)))
		 (else
		  (cons (if capitalize?
			    (char-upcase first)
			    first)
			(loop rest #f)))))))))

(define (native-method-name name)
  (cs-style name #t))
(define (native-field-name name)
  (cs-style name #f))